-- from "http://www.willamette.edu/~fruehr/haskell/evolution.html"

package examples.Evolution where

import frege.Prelude  hiding(zero, succ, •, id) -- avoid warnings
import Control.Semigroupoid
import Control.Category

--- explicit type recursion with functors and catamorphisms
data Mu f = !In (f (Mu f))

unIn (In x) = x

cata phi = phi • fmap (cata phi) • unIn


-- base functor and data type for natural numbers,
-- using locally-defined "eliminators"

data N c = Z | S c

instance Functor N where
  fmap g  Z    = Z
  fmap g (S x) = S (g x)

type Nat a = Mu (N a)

zero   = In  Z
succ n = In (S n)

add m = cata phi where
  phi  Z    = m
  phi (S f) = succ f

mult m = cata phi where
  phi  Z    = zero
  phi (S f) = add m f


-- explicit products and their functorial action

data Prod e c = Pair c e

outl (Pair x y) = x
outr (Pair x y) = y

fork f g x = Pair (f x) (g x)

instance Functor (Prod e) where
  fmap g = fork (g • outl) outr


-- comonads, the categorical "opposite" of monads

class Functor n => Comonad n where
  extr :: n a -> a
  dupl :: n a -> n (n a)

instance Comonad (Prod e) where
  extr = outl
  dupl = fork id outr


-- generalized catamorphisms, zygomorphisms and paramorphisms

gcata :: (Functor f, Comonad n) =>
           (forall a. f (n a) -> n (f a))
             -> (f (n c) -> c) -> Mu f -> c

gcata dist phi = extr • cata (fmap phi • dist • fmap dupl)

zygo chi = gcata (fork (fmap outl) (chi • fmap outr))

para :: Functor f => (f (Prod (Mu f) c) -> c) -> Mu f -> c
para = zygo In


--- factorial, the *hard* way!

fac = para phi where
  phi  Z             = succ zero
  phi (S (Pair f n)) = mult f (succ n)


-- for convenience and testing

int = cata phi where
  phi  Z    = 0
  phi (S f) = 1 + f

showmu = show • int

toMu 0 = zero
toMu n = succ (toMu (n-1))

{-
    X:\frege3>java -Xss1m -cp build examples.Evolution
    720
    runtime 0.063 wallclock seconds.
-}
main [arg] = println $ (showmu . fac . toMu . String.atoi) arg
main _ = println $ showmu (fac (succ (succ (succ (succ (succ (succ zero)))))))
